;;; -*- LISP -*-

(HERALD SDEBUG "")

;;;; Debugger support
;;;  Primitive procedures for crawling around inside of mucode data
;;;   structures such as continuations, environments, and histories.
;;; 
;;;
;;; Continuations


(DEFUN-IMPORT CALLING-CONTINUATION (CONTINUATION)
  (LET ((NAME (CONT-NAME CONTINUATION)))
    (IF (MEMQ NAME '(DONE UNCONTINUABLE))
	NIL	  
	(LET ((SAVED-RACKS (GET NAME 'RACKS)))		;actually CAR is it
	  (IF (MEMQ NAME '())
	      (PRINT "Warning: continuation may not be proceeded"))
	  (IF (NOT (NULL SAVED-RACKS))
	      (LET ((SI (NOINTERRUPT T)))
		(PROG1 (LET ((*THE-REGISTERS NIL)
			     (*THE-STACKS NIL)
			     (*FREE-MARKS NIL)
			     (*RACK-STATS NIL))
			 (RESET-RACKS)
			 (RESTORE-CONTROL-POINT CONTINUATION)
			 (MAPC '(LAMBDA (RACK-NAME)
				  (EVAL `(RESTORE ,RACK-NAME)))
			       (CAR SAVED-RACKS))
			 (RESTORE CONT)
			 (MAKE-CONTROL-POINT))
		       (NOINTERRUPT SI)))
	      (BUG-SCHEME-ERROR "Bad continuation code -- no racks declared"
				NAME))))))

(DEFUN-IMPORT CONTINUATION-ENVIRONMENT (CONTINUATION)
  (IF (REGISTER-SAVED? 'ENV CONTINUATION)
      (LET ((SI (NOINTERRUPT T)))
	(PROG1 (LET ((*THE-REGISTERS NIL)
		     (*THE-STACKS NIL)
		     (*FREE-MARKS NIL)
		     (*RACK-STATS NIL))
		 (RESET-RACKS)
		 (RESTORE-CONTROL-POINT CONTINUATION)
		 (RESTORE ENV)
		 (FETCH ENV))
	       (NOINTERRUPT SI)))
      'NO-ENVIRONMENT-SAVED))

(DEFUN REGISTER-SAVED? (REG CP)
  (LET ((RACKS (GET (CONT-NAME CP) 'RACKS)))
    (IF RACKS
	(MEMQ REG (CAR RACKS))
	(BUG-SCHEME-ERROR "Missing RACKS declaration for this continuation"
			  (CONT-NAME CP)))))

(DEFUN CONT-NAME (CP)
  (SUBR-NAME (CAR (CONTROL-POINT-CONT CP))))